home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / basic / apg_2.exe / PHONE.S&M < prev    next >
Encoding:
Text File  |  1993-03-18  |  19.7 KB  |  780 lines
  1. ''''''''''''''''''''''''''''''''''''''''''''''''''
  2. '                                                '
  3. '                General Phone List              '
  4. '                ------------------              '
  5. '                                                '
  6. '                 CREATED BY APG                 '
  7. '                 S & M SOFTWARE                 '
  8. '                 COPYRIGHT 1993                 '
  9. '                                                '
  10. '              USE file is PHONE.USE             '
  11. '                                                '
  12. '  Author: S&M Software                          '
  13. '  Date:   03-18-1993                            '
  14. '  Time:   10:39:13                              '
  15. '                                                '
  16. '  USE file Created         USE file Modified    '
  17. '  Date:   03-10-1993       Date:   03-14-1993   '
  18. '  Time:   22:50:08         Time:   11:18:01     '
  19. ''''''''''''''''''''''''''''''''''''''''''''''''''
  20.  
  21.  
  22. DEFINT A-Z
  23. CONST FALSE = 0, TRUE = NOT FALSE
  24. TYPE rectype                                'Define variables for file
  25.    pnbr AS STRING * 12
  26.    xName20 AS STRING * 30
  27.    xAddress AS STRING * 25
  28.    xcity40 AS STRING * 20
  29.    xstate50 AS STRING * 2 
  30.    xZip60 AS STRING * 10
  31.    xSpouse AS STRING * 10
  32.    xData80 AS STRING * 8 
  33.    xGift90 AS INTEGER
  34.    sts AS STRING * 1
  35. END TYPE
  36. TYPE indextype                              'Define index
  37.    recnum AS INTEGER
  38.    pnbr AS STRING * 12
  39. END TYPE
  40. DECLARE FUNCTION getinput$ (work$, fl%, nflg$, plen, prec, form$, act$, mode$)
  41. DECLARE SUB arrow (mode$, opt$, tracfld)
  42. DECLARE SUB clearfore ()
  43. DECLARE SUB displaydata ()
  44. DECLARE SUB export ()
  45. DECLARE SUB message (msg$, resp$)
  46. DECLARE SUB newrec (recnum, numofrec, maxrec, newkey$, exit$, mode$)
  47. DECLARE SUB nextrec (direc$, exit$, numofrec, recnum)
  48. DECLARE SUB sortindex ()
  49. DIM SHARED numofrec
  50. DIM SHARED f3.0$
  51. DIM SHARED phone AS rectype
  52. f3.0$ = "####"
  53.  
  54. ON ERROR GOTO errhandle
  55.  
  56. COLOR 15, 0
  57. CLS
  58.  
  59. OPEN "PHONE.DAT" FOR RANDOM AS #1 LEN = LEN(phone)
  60.  
  61. numofrec = LOF(1) \ LEN(phone)
  62. maxrec = numofrec + 100
  63. DIM SHARED index(1 TO maxrec)  AS indextype
  64. IF numofrec <> 0 THEN
  65.    FOR recnum = 1 TO numofrec
  66.       GET #1, recnum, phone
  67.       index(recnum).recnum = recnum
  68.       index(recnum).pnbr = phone.pnbr
  69.    NEXT
  70. END IF
  71. '
  72. '----- Print menu -----'
  73. '
  74. LOCATE 1, 29
  75. COLOR 7, 9
  76. PRINT "│                    │"
  77. LOCATE 1, 31
  78. PRINT "General Phone List"
  79. LOCATE 2, 29
  80. PRINT "│                    │"
  81. LOCATE 2, 31
  82. PRINT "------------------"
  83. sortindex                                   'sort records
  84. recnum = 0                                  'reset record number
  85.  
  86. LOCATE  5, 5: PRINT "01-Phone Number   "
  87. LOCATE  7, 5: PRINT "02-Name           "
  88. LOCATE  8, 5: PRINT "03-Address        "
  89. LOCATE  9, 5: PRINT "04-City           "
  90. LOCATE  10, 5: PRINT "05-State          "
  91. LOCATE  11, 5: PRINT "06-Zip Code       "
  92. LOCATE  13, 5: PRINT "07-Spouse's Name  "
  93. LOCATE  14, 5: PRINT "08-Birthday       "
  94. LOCATE  15, 5: PRINT "09-Gift Amount    "
  95. '
  96. '----- Start processing -----'
  97. '
  98. start:
  99. mode$ = ""
  100. phone.pnbr = ""
  101. phone.xName20 = ""
  102. phone.xAddress = ""
  103. phone.xcity40 = ""
  104. phone.xstate50 = ""
  105. phone.xZip60 = ""
  106. phone.xSpouse = ""
  107. phone.xData80 = ""
  108. phone.xGift90 = 0
  109. phone.sts = ""
  110. nflg$ = ""
  111. clearfore
  112. LOCATE  5,  24
  113. newkey$ = getinput$(phone.pnbr, 12, "L", 0, 0, "", act$, mode$)
  114. IF act$ = "PU" OR act$ = "PD" THEN
  115.    opt$ = act$
  116.    IF recnum = 0 THEN
  117.       IF opt$ = "PU" AND numofrec <> 0 THEN recnum = numofrec + 1
  118.    END IF
  119.    GOTO menu10
  120. END IF
  121. IF newkey$ = "            " GOTO fin
  122. IF UCASE$(newkey$) = "N           " THEN
  123.    opt$ = "N"
  124.    GOTO menu10
  125. END IF
  126. GOTO io
  127. '
  128. '------ Option bar -----'
  129. '
  130. menu:
  131. mode$ = "C"
  132. LOCATE 23, 1
  133. PRINT STRING$(80, " ")
  134. LOCATE 23, 12, 1
  135. COLOR 7, 9
  136. PRINT "FIELD #, PgUp, PgDn, ";
  137. PRINT "All, Next, Back, Delete, Sort, Export";
  138. COLOR 15, 0
  139. PRINT "  "
  140. COLOR 15, 9
  141. LOCATE 23, 18: PRINT "#"
  142. LOCATE 23, 33: PRINT "A"
  143. LOCATE 23, 38: PRINT "N"
  144. LOCATE 23, 44: PRINT "B"
  145. LOCATE 23, 50: PRINT "D"
  146. LOCATE 23, 58: PRINT "S"
  147. LOCATE 23, 64: PRINT "E"
  148.  
  149. COLOR 15, 0
  150. opt$ = ""
  151. menu5:
  152. LOCATE 23, 71
  153. PRINT opt$;
  154. DO
  155. instr$ = INKEY$
  156. LOOP WHILE instr$ = ""
  157.  
  158. IF INSTR("BANDSE", UCASE$(instr$)) > 0 THEN opt$ = instr$: GOTO menu10
  159. IF instr$ = CHR$(13) GOTO menu10
  160. IF instr$ = CHR$(27) GOTO menu
  161. IF instr$ = CHR$(8) GOTO menu
  162. IF LEN(instr$) = 2 THEN
  163.    code = ASC(RIGHT$(instr$, 1))
  164.    IF code = &H49 THEN opt$ = "PU"
  165.    IF code = &H51 THEN opt$ = "PD"
  166.    GOTO menu10
  167. END IF
  168. opt$ = opt$ + instr$
  169. GOTO menu5
  170. '
  171. '----- Start here for action keys -----'
  172. '
  173. menu10:  
  174. resp$ = ""
  175. IF opt$ = "" THEN GOTO start
  176. opt$ = UCASE$(opt$)
  177. IF MID$(opt$, 1, 1) = "0" THEN opt$ = MID$(opt$, 2, 1)
  178. LOCATE 23, 1
  179. PRINT STRING$(80, " ")
  180. LOCATE 23, 6, 1
  181. COLOR 7, 9
  182. IF INSTR("SEBNPUPD", opt$) = 0 THEN
  183. PRINT "Active Keys: <PgUp>, <PgDn>, <Arrows>, <Del>, <Ins>, <Esc> or <Enter>";
  184. COLOR 15, 9
  185. LOCATE 23, 20: PRINT "PgUp";
  186. LOCATE 23, 28: PRINT "PgDn";
  187. LOCATE 23, 36: PRINT "Arrows";
  188. LOCATE 23, 46: PRINT "Del";
  189. LOCATE 23, 53: PRINT "Ins";
  190. LOCATE 23, 60: PRINT "Esc";
  191. LOCATE 23, 69: PRINT "Enter";
  192. END IF
  193. COLOR 15, 0
  194.  
  195. SELECT CASE opt$
  196.    CASE "1"
  197.       message "Can not change index - Press any key", resp$
  198.       GOTO menu
  199.    CASE "2"
  200.       GOTO fld20                             'Name                          
  201.    CASE "3"
  202.       GOTO fld30                             'Address                       
  203.    CASE "4"
  204.       GOTO fld40                             'City                          
  205.    CASE "5"
  206.       GOTO fld50                             'State                         
  207.    CASE "6"
  208.       GOTO fld60                             'Zip Code                      
  209.    CASE "7"
  210.       GOTO fld70                             'Spouse's Name                 
  211.    CASE "8"
  212.       GOTO fld80                             'Birthday                      
  213.    CASE "9"
  214.       GOTO fld90                             'Gift Amount                   
  215.    CASE "A"
  216.       mode$ = "A"
  217.       GOTO fld20
  218.    CASE "N", "PD"
  219.       direc$ = "F"
  220.       nextrec direc$, exit$, numofrec, recnum
  221.       IF exit$ = "A" GOTO start
  222.       GOTO menu
  223.    CASE "B", "PU"
  224.       direc$ = "B"
  225.       nextrec direc$, exit$, numofrec, recnum
  226.       IF exit$ = "A" GOTO start
  227.       GOTO menu
  228.    CASE "D"
  229.       phone.sts = "D"
  230.       GOTO del
  231.    CASE "S"
  232.       resp$ = "1"
  233.       message "Sorting file - Please wait", resp$
  234.       sortindex
  235.       resp$ = "2"
  236.       message "", resp$
  237.    CASE "E"
  238.       CLOSE (2)
  239.       KILL "phone.exp"
  240.       resp$ = "1"
  241.       message "Preparing file for export - Please wait", resp$
  242.       export
  243.       resp$ = "2"
  244.       message "", resp$
  245.       GET #1, recnum, phone
  246. END SELECT
  247. GOTO menu
  248. '
  249. '----- Input fields -----'
  250. '
  251. fld20:                                       'Name                          
  252. tracfld = 2
  253. LOCATE  7,  24
  254. phone.xName20 = getinput$(phone.xName20, 30, "L", 0, 0, "", act$, mode$)
  255. LOCATE 25, 1
  256. PRINT STRING$(80, " ");
  257. IF phone.xName20 = "                              " AND mode$ <> "C" THEN
  258.    GOTO start
  259. END IF
  260. IF mode$ = "C" OR act$ <> "" GOTO add
  261.  
  262. fld30:                                       'Address                       
  263. tracfld = 3
  264. LOCATE  8,  24
  265. phone.xAddress = getinput$(phone.xAddress, 25, "L", 0, 0, "", act$, mode$)
  266. IF mode$ = "C" OR act$ <> "" GOTO add
  267.  
  268. fld40:                                       'City                          
  269. tracfld = 4
  270. LOCATE  9,  24
  271. phone.xcity40 = getinput$(phone.xcity40, 20, "L", 0, 0, "", act$, mode$)
  272. IF mode$ = "C" OR act$ <> "" GOTO add
  273.  
  274. fld50:                                       'State                         
  275. tracfld = 5
  276. LOCATE  10,  24
  277. phone.xstate50 = getinput$(phone.xstate50, 2 , "L", 0, 0, "", act$, mode$)
  278. IF mode$ = "C" OR act$ <> "" GOTO add
  279.  
  280. fld60:                                       'Zip Code                      
  281. tracfld = 6
  282. LOCATE  11,  24
  283. phone.xZip60 = getinput$(phone.xZip60, 10, "L", 0, 0, "", act$, mode$)
  284. IF mode$ = "C" OR act$ <> "" GOTO add
  285.  
  286. fld70:                                       'Spouse's Name                 
  287. tracfld = 7
  288. LOCATE  13,  24
  289. phone.xSpouse = getinput$(phone.xSpouse, 10, "L", 0, 0, "", act$, mode$)
  290. IF mode$ = "C" OR act$ <> "" GOTO add
  291.  
  292. fld80:                                       'Birthday                      
  293. tracfld = 8
  294. LOCATE  14,  24
  295. phone.xData80 = getinput$(phone.xData80, 8 , "L", 0, 0, "", act$, mode$)
  296. IF mode$ = "C" OR act$ <> "" GOTO add
  297.  
  298. fld90:                                       'Gift Amount                   
  299. tracfld = 9
  300. LOCATE  15,  24
  301. IF mode$ = "N" THEN
  302. xGift90$ = STRING$( 5, " ")
  303. ELSE
  304. xGift90$ = STR$(phone.xGift90) + STRING$( 5, " ")
  305. END IF
  306. phone.xGift90 = VAL(getinput$(xGift90$, 5, "N", 3, 0, f3.0$, act$, mode$))
  307. IF mode$ = "C" OR act$ <> "" GOTO add
  308.  
  309. '
  310. '----- Add or change record or field -----'
  311. '
  312. add:                                        'Add record
  313. newrec recnum, numofrec, maxrec, newkey$, exit$, mode$
  314. IF exit$ = "Y" THEN GOTO fin
  315. IF act$ = "" GOTO menu
  316. IF act$ = "PD" THEN direc$ = "F"
  317. IF act$ = "PU" THEN direc$ = "B"
  318. IF act$ = "PD" OR act$ = "PU" THEN
  319.    nextrec direc$, exit$, numofrec, recnum
  320.    IF exit$ = "A" GOTO start
  321.    GOTO menu10
  322. END IF
  323. IF mode$ = "N" THEN mode$ = "Z"
  324. IF act$ = "AU" THEN
  325.    IF tracfld - 1 < 2 THEN
  326.       BEEP
  327.       tracfld = 3
  328.    END IF
  329.    opt$ = MID$(STR$(tracfld - 1), 2)
  330.    GOTO menu10
  331. END IF
  332. IF act$ = "AD" THEN
  333.    IF tracfld + 1 > 9 THEN
  334.       BEEP
  335. tracfld = 8
  336.    END IF
  337.    opt$ = MID$(STR$(tracfld + 1), 2)
  338.    GOTO menu10
  339. END IF
  340.  
  341. del:                                        'Delete record
  342. PUT #1, index(recnum).recnum, phone
  343. phone.sts = ""
  344. GOTO start
  345. '
  346. '----- Set for new or get exsisting record -----'
  347. '
  348. io:
  349. FOR recnum = 1 TO numofrec
  350.    IF index(recnum).pnbr = newkey$ THEN GOTO io10
  351. NEXT
  352.    mode$ = "N"
  353.    phone.pnbr = newkey$
  354.    resp$ = "1"
  355.    message "New record - Enter field data or <ENTER> to abort", resp$
  356.    GOTO fld20
  357. io10:
  358. GET #1, index(recnum).recnum, phone
  359. IF phone.sts = "D" THEN
  360.    message "This record has been deleted - Do you wish to restore y/N ", resp$
  361.    IF UCASE$(resp$) = "Y" THEN
  362.       phone.sts = ""
  363.       PUT #1, index(recnum).recnum, phone
  364.    ELSE
  365.       GOTO start
  366.    END IF
  367. END IF
  368. displaydata
  369. GOTO menu
  370. '
  371. '----- End program -----'
  372. '
  373. fin:
  374. CLS
  375. CLOSE
  376. END
  377. '
  378. '----- Error handling -----'
  379. '
  380. errhandle:
  381. IF ERR = 53 THEN
  382.    RESUME NEXT
  383. END IF
  384. CLS
  385. PRINT "Unexpected error "; ERR
  386. PRINT "Please note this error number and consult your QuickBasic Manual!"
  387. INPUT "", a$
  388. CLOSE
  389. END
  390.  
  391. SUB arrow (mode$, opt$, tracfld)
  392. IF mode$ = "AU" THEN
  393.    opt$ = MID$(STR$(tracfld - 1), 2)
  394.    EXIT SUB
  395. END IF
  396. IF mode$ = "AD" THEN
  397.    opt$ = MID$(STR$(tracfld + 1), 2)
  398.    EXIT SUB
  399. END IF
  400. END SUB
  401.  
  402. SUB clearfore
  403. COLOR 15, 0
  404. LOCATE  5, 24
  405. PRINT STRING$(12, " ")
  406. LOCATE  7, 24
  407. PRINT STRING$(30, " ")
  408. LOCATE  8, 24
  409. PRINT STRING$(25, " ")
  410. LOCATE  9, 24
  411. PRINT STRING$(20, " ")
  412. LOCATE  10, 24
  413. PRINT STRING$(2, " ")
  414. LOCATE  11, 24
  415. PRINT STRING$(10, " ")
  416. LOCATE  13, 24
  417. PRINT STRING$(10, " ")
  418. LOCATE  14, 24
  419. PRINT STRING$(8, " ")
  420. LOCATE  15, 24
  421. PRINT STRING$(5, " ")
  422. LOCATE 23, 1
  423. PRINT STRING$(80, " ")
  424. LOCATE 23, 4
  425. PRINT "Enter key information, <N> for next, <PgUp>, <PgDn>, or <ENTER> to exit"
  426. END SUB
  427.  
  428. SUB displaydata
  429. LOCATE 5, 24: PRINT phone.pnbr    
  430. LOCATE 7, 24: PRINT phone.xName20 
  431. LOCATE 8, 24: PRINT phone.xAddress
  432. LOCATE 9, 24: PRINT phone.xcity40 
  433. LOCATE 10, 24: PRINT phone.xstate50
  434. LOCATE 11, 24: PRINT phone.xZip60  
  435. LOCATE 13, 24: PRINT phone.xSpouse 
  436. LOCATE 14, 24: PRINT phone.xData80 
  437. LOCATE 15, 24: PRINT USING f3.0$; phone.xGift90 
  438. END SUB
  439.  
  440. SUB export
  441. q$ = CHR$(34)
  442. OPEN "phone.exp" FOR OUTPUT AS #2
  443.  
  444. FOR i = 1 TO numofrec
  445. GET #1, i, phone
  446. data$ = q$ + phone.pnbr + q$ + ","
  447. data$ = data$ + q$ + phone.xName20 + q$ + ","
  448. data$ = data$ + q$ + phone.xAddress + q$ + ","
  449. data$ = data$ + q$ + phone.xcity40 + q$ + ","
  450. data$ = data$ + q$ + phone.xstate50 + q$ + ","
  451. data$ = data$ + q$ + phone.xZip60 + q$ + ","
  452. data$ = data$ + q$ + phone.xSpouse + q$ + ","
  453. data$ = data$ + q$ + phone.xData80 + q$ + ","
  454. data$ = data$ + STR$(phone.xGift90) 
  455. PRINT #2, data$
  456. NEXT i
  457. END SUB
  458.  
  459. FUNCTION getinput$ (work$, fl, nflg$, plen, prec, form$, act$, mode$)
  460. '
  461. ' ----- set varailbles -----'
  462. '
  463. crow = CSRLIN
  464. ccol = POS(0)
  465. beg = ccol - 1
  466. maxcol = ccol + fl - 1
  467. mincol = ccol
  468. new$ = "N"
  469. act$ = ""
  470. GOTO begin5
  471. '
  472. ' ----- get inputed character -----'
  473. '
  474. begin:
  475. BEEP
  476. begin5:
  477. dotpos = INSTR(work$, ".")
  478. signpos = INSTR(work$, "-")
  479. IF dotpos = 0 THEN dot = 0
  480. IF signpos = 0 THEN sign = 0
  481. code = 0
  482. LOCATE crow, mincol, 1
  483. IF nflg$ = "L" OR edit$ = "Y" THEN PRINT work$;
  484. work# = VAL(work$)
  485. IF nflg$ = "N" AND edit$ = "" THEN PRINT USING form$; work#
  486. LOCATE crow, ccol, , 7
  487. IF insert$ = "Y" THEN LOCATE crow, ccol, 1, 0, 7
  488. DO
  489. instr$ = INKEY$
  490. LOOP WHILE instr$ = ""
  491. '
  492. ' ----- is it a special character? -----'
  493. '
  494. IF instr$ = CHR$(27) THEN work$ = STRING$(fl, " "): ccol = mincol: GOTO begin5
  495. IF instr$ = CHR$(8) THEN dir$ = "L": key$ = "B": GOTO begin10
  496. IF LEN(instr$) = 2 THEN
  497.    code = ASC(RIGHT$(instr$, 1))
  498.    IF code = &H4B THEN dir$ = "L": key$ = "L": GOTO begin10  'Left arrow
  499.    IF code = &H4D THEN dir$ = "R": key$ = "R": GOTO begin10  'Right arrow
  500.    IF code = &H4F THEN dir$ = "R": key$ = "E": GOTO begin10  'End
  501.    IF code = &H47 THEN dir$ = "L": key$ = "H": GOTO begin10  'Home
  502.    IF code = &H52 THEN                                           'Insert
  503.       IF insert$ = "" THEN
  504.          dir$ = "L"
  505.          key$ = "I"
  506.          insert$ = "Y"
  507.          GOTO begin10
  508.       ELSE
  509.          insert$ = ""
  510.          dir$ = "R"
  511.          key$ = "R"
  512.          GOTO begin10
  513.       END IF
  514.    END IF
  515.    IF code = &H53 THEN dir$ = "R": key$ = "D": GOTO begin10  'Delete
  516.    IF code = &H49 THEN act$ = "PU": GOTO begin10             'Page up
  517.    IF code = &H51 THEN act$ = "PD": GOTO begin10             'Page down
  518.    IF code = &H48 THEN act$ = "AU": GOTO begin10             'Up arrow
  519.    IF code = &H50 THEN act$ = "AD": GOTO begin10             'Down arrow
  520.    GOTO begin
  521. ELSE
  522. dir$ = "R": key$ = "R"
  523. END IF
  524. '
  525. ' ----- does this character request an exit? ------ '
  526. '
  527. begin10:
  528. IF instr$ = CHR$(13) OR LEN(act$) = 2 THEN
  529.    IF nflg$ = "L" THEN
  530.       getinput$ = work$
  531.       EXIT FUNCTION
  532.    ELSE
  533.       dec = INSTR(work$, ".")
  534.       IF dec = 0 AND edit$ = "Y" THEN
  535.          IF prec = 0 THEN
  536.             getinput$ = work$
  537.             EXIT FUNCTION
  538.          END IF
  539.          factor$ = "." + RIGHT$("000000000001", prec)
  540.          worknum# = VAL(work$) * VAL(factor$)'
  541.          getinput$ = STR$(worknum#)
  542.          EXIT FUNCTION
  543.        ELSE
  544.             getinput$ = work$
  545.             EXIT FUNCTION
  546.        END IF
  547.    END IF
  548. END IF
  549. IF code = 0 AND instr$ <> CHR$(8) GOTO valid
  550. '
  551. ' ----- perform action of special key ----- '
  552. '
  553. IF dir$ = "R" AND ccol = maxcol THEN GOTO begin
  554. IF dir$ = "L" AND ccol = mincol AND key$ = "B" AND LEN(RTRIM$(work$)) = 1 THEN
  555.    MID$(work$, 1, 1) = " ": GOTO begin5
  556. END IF
  557. IF dir$ = "L" AND ccol = mincol THEN GOTO begin
  558. SELECT CASE key$
  559.    CASE "L"
  560.       ccol = ccol - 1
  561.    CASE "R"
  562.       ccol = ccol + 1
  563.       IF ccol > maxcol THEN
  564.          BEEP
  565.          ccol = maxcol
  566.       END IF
  567.    CASE "E"
  568.       ccol = mincol + LEN(RTRIM$(work$))
  569.    CASE "H"
  570.       ccol = mincol
  571.    CASE "D"
  572.       work$ = MID$(work$, 1, ccol - beg - 1) + MID$(work$, ccol - beg + 1, fl) + " "
  573.    CASE "B"
  574.       work$ = MID$(work$, 1, ccol - beg - 2) + MID$(work$, ccol - beg, fl) + " "
  575.       ccol = ccol - 1
  576.    END SELECT
  577. GOTO begin5
  578. '
  579. ' ----- check validity of inputed character ----- '
  580. '
  581. valid:
  582.  
  583. IF nflg$ = "L" THEN
  584.    IF insert$ = "Y" THEN
  585.       work1$ = MID$(work$, 1, ccol - beg - 1)
  586.       work2$ = MID$(work$, ccol - beg, fl)
  587.       work$ = work1$ + instr$ + work2$
  588.       work$ = MID$(work$, 1, fl)
  589.       ccol = ccol + 1
  590.       IF ccol > maxcol THEN
  591.          ccol = maxcol
  592.          GOTO begin
  593.       END IF
  594.       GOTO begin5
  595.    END IF
  596.    MID$(work$, ccol - beg) = instr$
  597.    ccol = ccol + 1
  598.    IF ccol > maxcol THEN
  599.       ccol = maxcol
  600.       GOTO begin
  601.    END IF
  602.    GOTO begin5
  603. END IF
  604. IF new$ = "N" THEN
  605.    blen = plen + prec + 2
  606.    blank$ = STRING$(blen, " ")
  607.    work$ = blank$: new$ = ""
  608. END IF
  609. IF ccol = mincol THEN
  610.    PRINT work$
  611.    LOCATE crow, mincol
  612.    edit$ = "Y"
  613.    first = INSTR("-.1234567890", instr$)
  614.    SELECT CASE first
  615.       CASE 0
  616.          GOTO begin
  617.       CASE 1
  618.          sign = 1
  619.          GOTO accept
  620.       CASE 2
  621.          IF dot = 1 THEN
  622.             GOTO begin
  623.          END IF
  624.          dot = 1
  625.          GOTO accept
  626.    END SELECT
  627.    GOTO accept
  628. END IF
  629. other = INSTR(".1234567890", instr$)
  630. SELECT CASE other
  631.    CASE 0
  632.       GOTO begin
  633.    CASE 1
  634.       IF dot = 1 THEN
  635.          GOTO begin
  636.       END IF
  637.       dot = 1
  638.       GOTO accept
  639. END SELECT
  640. GOTO accept
  641. '
  642. ' ------ accept valid numeric and manipulate ----- '
  643. '
  644. accept:
  645. IF prec = 0 THEN
  646.    IF instr$ = "." AND ccol <> mincol + plen + sign GOTO begin
  647.    maxlen = plen + sign + dot
  648.    IF LEN(RTRIM$(work$)) = maxlen THEN
  649.       GOTO begin
  650.    ELSE
  651.       MID$(work$, ccol - beg) = instr$
  652.       ccol = ccol + 1
  653.       GOTO accept10
  654.    END IF
  655. END IF
  656.  
  657. dotpos = INSTR(work$, ".")
  658. IF dotpos = 0 THEN
  659.    maxlen = plen + sign
  660.    IF LEN(RTRIM$(work$)) = maxlen THEN
  661.       IF instr$ <> "." THEN
  662.          MID$(work$, ccol - beg) = "." + instr$
  663.          ccol = ccol + 2
  664.          GOTO accept10
  665.       ELSE
  666.          MID$(work$, ccol - beg) = instr$
  667.          ccol = ccol + 1
  668.          GOTO accept10
  669.       END IF
  670.    ELSE
  671.       MID$(work$, ccol - beg) = instr$
  672.       ccol = ccol + 1
  673.       GOTO accept10
  674.    END IF
  675. ELSE
  676.    IF instr$ = "." THEN GOTO begin
  677.    maxlenpr = prec + dotpos
  678.    IF prec = 0 THEN maxlenpr = plen
  679.    IF LEN(RTRIM$(work$)) = maxlenpr THEN
  680.       GOTO begin
  681.    ELSE
  682.       MID$(work$, ccol - beg) = instr$
  683.       ccol = ccol + 1
  684.       GOTO accept10
  685.    END IF
  686. END IF
  687. accept10:
  688. GOTO begin5
  689.  
  690. END FUNCTION
  691.  
  692. SUB message (msg$, resp$)
  693. '
  694. ' resp$ = "" wait for response
  695. ' resp$ = "1" don't clear message, exit
  696. ' resp$ = "2" clear message, exit
  697. '
  698. IF resp$ = "2" THEN GOTO msg10
  699. IF resp$ = "" THEN BEEP
  700. Y = (80 - LEN(msg$)) / 2
  701. LOCATE 23, 1
  702. PRINT STRING$(80, " ")
  703. LOCATE 25, Y, 0
  704. PRINT msg$;
  705. IF resp$ = "1" THEN EXIT SUB
  706. DO
  707. resp$ = INKEY$
  708. LOOP WHILE resp$ = ""
  709. LOCATE 25, Y
  710. PRINT STRING$(LEN(msg$), " ");
  711. EXIT SUB
  712. msg10:
  713. LOCATE 25, 1
  714. PRINT STRING$(80, " ");
  715. END SUB
  716.  
  717. SUB newrec (recnum, numofrec, maxrec, newkey$, exit$, mode$)
  718. IF mode$ = "N" THEN
  719.    numofrec = numofrec + 1
  720.    IF numofrec = maxrec THEN
  721.       message "Can not add any more records this session - Restart", resp$
  722.       exit$ = "Y"
  723.    END IF
  724. PUT #1, numofrec, phone
  725.    index(numofrec).recnum = numofrec
  726.    index(numofrec).pnbr = newkey$
  727. ELSE
  728.    PUT #1, index(recnum).recnum, phone
  729. END IF
  730. END SUB
  731.  
  732. SUB nextrec (direc$, exit$, numofrec, recnum)
  733. exit$ = ""
  734. IF direc$ = "F" THEN recnum = recnum + 1
  735. IF direc$ = "B" THEN recnum = recnum - 1
  736. IF recnum > numofrec THEN
  737.    message "End of file - Press any key", resp$
  738.    recnum = 0
  739.    exit$ = "A"
  740.    EXIT SUB
  741. END IF
  742. IF recnum = 0 THEN
  743.    message "Start of file - Press any key", resp$
  744.    exit$ = "A"
  745.    EXIT SUB
  746. END IF
  747. get #1, index(recnum).recnum, phone
  748. IF phone.sts = "D" THEN
  749.    message "This record has been deleted - Do you wish to restore y/N ", resp$
  750.    IF UCASE$(resp$) = "Y" THEN
  751.       phone.sts = ""
  752.       PUT #1, index(recnum).recnum, phone
  753.    ELSE
  754.       exit$ = "A"
  755.       EXIT SUB
  756.    END IF
  757. END IF
  758. displaydata
  759. END SUB
  760.  
  761. SUB sortindex STATIC
  762. SHARED index() AS indextype, numofrec
  763. offset = numofrec \ 2
  764. DO WHILE offset > 0
  765.    limit = numofrec - offset
  766.    DO
  767.       switch = FALSE
  768.       FOR i = 1 TO limit
  769.          IF index(I).pnbr > index(I + offset).pnbr THEN
  770.             SWAP index(i), index(i + offset)
  771.             switch = i
  772.          END IF
  773.       NEXT i
  774.       limit = switch
  775.    LOOP WHILE switch
  776.    offset = offset \ 2
  777. LOOP
  778. END SUB
  779.  
  780.